{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving #-}
module Control.Monad.TreeGenerator where

import Data.Monoid

import Data.TreeLike
import Data.Tree
import Data.EitherLike

import Control.Monad.Writer
import Control.Monad.State

import LLVM.Parser.Record.Parser
import LLVM.Parser.Record.Record

import Data.TreeLike

newtype TreeGeneratorT lbl elem tt monad a = TGWrap {unTGWrap::StateT tt monad a}
        deriving(Functor,Monad,MonadTrans,MonadPlus,MonadFix)

-- (EitherLike elem tt br) is assumed by (TreeLike tt br elem), but stupid typer
-- want to see it explicitelly
yield :: (Monad m, TreeLike tt lbl elem) => elem -> TreeGeneratorT lbl elem tt m ()
yield a = TGWrap $ modify (`leaf` a)
-- tell $ L.singleton a

collect :: (Monad m, TreeLike tt lbl elem) => TreeGeneratorT lbl elem tt m a -> m tt
collect tgt = execStateT (unTGWrap tgt) tlempty

gbranch :: (Monad m, TreeLike tt lbl elem) => TreeGeneratorT lbl elem tt m a -> lbl -> TreeGeneratorT lbl elem tt m ()
gbranch input label = do
                        val <- lift $ collect input
                        TGWrap $ modify (\x -> branch x label val)
                        return ()



foo :: Maybe Integer
foo = Just 23

tst0 = do
           yield "1"
           yield "2"
           yield "4"
           yield "3"
           yield "4"
           yield "8"
           return ()

tst :: Maybe ([Tree String])
tst = collect $ do
                    tst0
                    gbranch tst0 "2"
                    gbranch tst0 "3"
                    return ()

unJust :: Maybe a -> a
unJust (Just x) = x
